home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / 5.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-01-30  |  30.6 KB  |  1,147 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* Todo: 
  10.  
  11.  3-12-86    ds    
  12.  Modify format of as_return node so that new node of type as_number
  13.  put in N_AST3 field to hold depth count formerly kept in N_VAL.
  14.  
  15.  30-oct-84    ds
  16.  Note that N_VAL for node produced at end of return_statement()
  17.  is different, is now integer giving depth, was tuple of length two.
  18.  
  19.  
  20. id is defined in goto_statement but never used
  21.  
  22. */
  23.  
  24. #include "attr.h"
  25. #include "hdr.h"
  26. #include "vars.h"
  27. #include "setp.h"
  28. #include "dclmapp.h"
  29. #include "miscp.h"
  30. #include "errmsgp.h"
  31. #include "dbxp.h"
  32. #include "evalp.h"
  33. #include "nodesp.h"
  34. #include "smiscp.h"
  35. #include "chapp.h"
  36.  
  37. #define label_unreachable 0
  38. #define label_reachable 1
  39.  
  40. static void new_symbol(Symbol, int, Symbol, Tuple, Symbol);
  41. static Const get_static_nval(Node);
  42. static void replace_others(Node, Node, int, int);
  43.  
  44. Symbol slice_type(Node node, int is_renaming)         /*;slice_type*/
  45. {
  46.     Node   array_node, range_node, low_node, high_node, type_node;
  47.     Node   new_range_node, arg1, arg2, var_node;
  48.     Symbol type_name, type_mark, index_name, i_type;
  49.     Tuple  tup;
  50.     int    attr_prefix, kind;
  51.  
  52.     /* We must have a subtype for the aggregate to give the bounds */
  53.     if (is_renaming) {
  54.         var_node = N_AST3(node);
  55.     } 
  56.     else
  57.         var_node = N_AST1(node);
  58.     array_node = N_AST1(var_node);
  59.     range_node = N_AST2(var_node);
  60.     kind = N_KIND(range_node);
  61.     if (kind == as_simple_name || kind == as_name)
  62.         type_name = N_UNQ(range_node);
  63.     else {
  64.         if (kind == as_subtype) {
  65.             type_node = N_AST1(range_node);
  66.             new_range_node = N_AST2(range_node);
  67.             low_node  = N_AST1(new_range_node);
  68.             high_node = N_AST2(new_range_node);
  69.         }
  70.         else if (kind == as_range) {
  71.             low_node = N_AST1(range_node);
  72.             high_node = N_AST2(range_node);
  73.         }
  74.         else if (kind == as_attribute) {
  75.             /*att_node = N_AST1(range_node); -- not needed in C */
  76.             arg1 = N_AST2(range_node);
  77.             arg2 = N_AST3(range_node);
  78.             /* subtract code for ATTR_FIRST to get T_ or O_ value */
  79.             /* recall that in C attribute kind kept in range_node*/
  80.             attr_prefix = (int)attribute_kind(range_node)-ATTR_RANGE;
  81.             /* 'T' or 'O' */
  82.             attribute_kind(range_node) = (char *)((int) attr_prefix+ATTR_FIRST);
  83.             low_node = range_node;
  84.             high_node = new_attribute_node(attr_prefix+ATTR_LAST,
  85.               copy_node(arg1), copy_node(arg2), get_type(range_node));
  86.             eval_static(low_node);
  87.             eval_static(high_node);
  88.         }
  89.         else {
  90.             errmsg("Unexpected range in slice", "", range_node );
  91.             low_node = OPT_NODE;
  92.             high_node = OPT_NODE;
  93.         }
  94.         /* We need the bounds twice, for the slice and for the aggregate
  95.          * so we build an anonymous subtype to avoid double evaluation
  96.          */
  97.         if (N_KIND(array_node) == as_simple_name
  98.           || N_KIND(array_node) == as_name)
  99.             type_mark = TYPE_OF(N_UNQ(array_node));
  100.         else
  101.             type_mark = N_TYPE(array_node);
  102.         type_mark = base_type(type_mark);        /* get base type */
  103.         index_name = named_atom("slice_index_type");
  104.         type_name = named_atom("slice_type");
  105.         i_type= (Symbol) index_type(type_mark);
  106.         tup = constraint_new(0);
  107.         tup[2] = (char *) low_node;
  108.         tup[3] = (char *) high_node;
  109.         new_symbol(index_name, na_subtype, i_type, tup, ALIAS(i_type));
  110.         SCOPE_OF(index_name) = scope_name;
  111.  
  112.         tup = constraint_new(4);
  113.         tup[1] = (char *) tup_new1((char *) index_name);
  114.         tup[2] = (char *) component_type(type_mark);
  115.  
  116.         new_symbol(type_name, na_subtype, type_mark, tup, ALIAS(type_mark));
  117.         SCOPE_OF(type_name) = scope_name;
  118.         tup = tup_new(2);
  119.         tup[1] = (char *) new_subtype_decl_node(index_name);
  120.         tup[2] = (char *) new_subtype_decl_node(type_name);
  121.         make_insert_node(node, tup, copy_node(node));
  122.         N_AST1(var_node)  = array_node;
  123.         N_AST2(var_node)  = new_name_node(index_name);
  124.         copy_span(range_node, N_AST2(var_node));
  125.     }
  126.     return type_name;
  127. }
  128.  
  129. static void new_symbol(Symbol new_name, int new_nature, Symbol new_type,
  130.   Tuple new_signature, Symbol new_alias)                        /*;new_symbol*/
  131. {
  132.     NATURE(new_name)    = new_nature;
  133.     TYPE_OF(new_name)    = new_type;
  134.     SIGNATURE(new_name) = new_signature;
  135.     ALIAS(new_name)    = new_alias;
  136.     dcl_put(DECLARED(scope_name), str_newat(), new_name);
  137. }
  138.  
  139. Symbol get_type(Node node)                                        /*;get_type*/
  140. {
  141.     /*
  142.      * GET_TYPE is procedure get_type() in C:
  143.      *     macro GET_TYPE(node);
  144.      *  (if N_KIND(node) in [as_simple_name, as_subtype_indic]
  145.      *                        then TYPE_OF(N_UNQ(node))
  146.      *                        }
  147.      *                        else N_TYPE(node) end )                   endm;
  148.      */
  149.  
  150.     int    nk;
  151.     Symbol    sym;
  152.  
  153.     nk = N_KIND(node);
  154.     if (nk == as_simple_name || nk == as_subtype_indic) {
  155.         sym = N_UNQ(node);
  156.         if (sym == (Symbol)0) {
  157. #ifdef DEBUG
  158.             zpnod(node);
  159. #endif
  160.             chaos("get_type: N_UNQ not defined for node");
  161.         }
  162.         else
  163.             sym =  TYPE_OF(sym);
  164.     }
  165.     else
  166.         sym = N_TYPE(node);
  167.  
  168.     return sym;
  169. }
  170.  
  171. void assign_statement(Node node)  /*;assign_statement*/ 
  172. {
  173.     Node var_node, exp_node;
  174.     Symbol t, t1, t2, ok_sym;
  175.     Set    t_l, t_left, t_right, ok_types, ook_types;
  176.     Forset    tiv, tforl, tforr, fs1;
  177.  
  178.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  assign_statement");
  179.  
  180.     var_node = N_AST1(node);
  181.     exp_node = N_AST2(node);
  182.  
  183.     noop_error = FALSE;        /* To clear previous type errors */
  184.  
  185.     adasem(var_node);
  186.     find_old(var_node);            /* left-hand side is a name.*/
  187.     adasem(exp_node);
  188.  
  189.     resolve1(var_node);
  190.     t_l = N_PTYPES(var_node);
  191.     t_left = set_new(0);
  192.     FORSET(t = (Symbol), t_l, tiv);
  193.         if (! is_limited_type(t)) t_left = set_with(t_left, (char *) t);
  194.     ENDFORSET(tiv);
  195.     resolve1(exp_node);
  196.     t_right = N_PTYPES(exp_node);
  197.  
  198.     if (noop_error) {    /* previous error. */
  199.         noop_error = FALSE;
  200.         return;
  201.     }
  202.  
  203.     ok_types = set_new(0);
  204.     FORSET(t1 = (Symbol), t_left, tforl);
  205.         FORSET(t2 = (Symbol), t_right, tforr);
  206.             if (compatible_types(t1, t2) )
  207.                 ok_types = set_with(ok_types, (char *) t1);
  208.         ENDFORSET(tforr);
  209.     ENDFORSET(tforl);
  210.     /* For the assignment to be unambiguous, the left-hand and right_hand
  211.      * sides must have a single compatible interpretation.
  212.      */
  213.     if (set_size(ok_types) == 0) {
  214.         if (set_size(t_l) == 1 && set_size(t_left) == 0) {
  215.             errmsg("assignment not available on a limited type", "7.4.2",
  216.               var_node);
  217.             set_free(ok_types);
  218.             return;
  219.         }
  220.         else {
  221.             errmsg("incompatible types for assignment", "5.2", node);
  222.             set_free(ok_types);
  223.             return;
  224.         }
  225.     }
  226.     else if (set_size(ok_types) > 1) {    /* ambiguous left-hand side */
  227.         remove_conversions(var_node);        /* last chance. */
  228.         ook_types = ok_types;
  229.         ok_types = set_new(0);
  230.         FORSET(ok_sym=(Symbol), N_PTYPES(var_node), fs1);
  231.             if (set_mem((char *) ok_sym, ook_types))
  232.                 ok_types = set_with(ok_types, (char *)ok_sym);
  233.         ENDFORSET(fs1);
  234.         set_free(ook_types);
  235.         if (set_size(ok_types) != 1) {
  236.             errmsg("ambiguous types for assigment", "5.2", var_node);
  237.             set_free(ok_types);
  238.             return;
  239.         }
  240.     }
  241.     t1 = (Symbol) set_arb(ok_types);  /* Now unique. */
  242.     set_free(ok_types);
  243.     out_context = TRUE;
  244.     resolve2(var_node, t1);
  245.     out_context = FALSE;
  246.     /*if (N_KIND(var_node) == as_slice && (N_KIND(exp_node) == as_aggregate
  247.         ||N_KIND(exp_node) == as_string_literal)){*/
  248.  
  249.     /* we don't have to care about the type of the right hand side cf Setl */
  250.     if (N_KIND(var_node) == as_slice) {
  251.         /* context is constrained, even though type of lhs is base type
  252.          * This means that an OTHERS association is allowed.
  253.          */
  254.         t1 = slice_type(node,0);
  255.         resolve2 (exp_node, t1);
  256.         return;
  257.     }
  258.  
  259.     if(NATURE(t1) == na_array && N_UNQ(var_node) != (Symbol)0 &&
  260.       (NATURE(N_UNQ(var_node))==na_inout || NATURE(N_UNQ(var_node))==na_out))
  261.         replace_others(exp_node, var_node, tup_size(index_types(t1)), 1);
  262.  
  263.     resolve2(exp_node, t1);
  264.  
  265.     if (! is_variable(var_node)){
  266.         errmsg("left-hand side in assignment is not a variable", "5.2",
  267.           var_node);
  268.         return;
  269.     }
  270.  
  271.     if (is_array(t1) ) {
  272.         /* array assignments are length_checked in the interpreter, and don't
  273.          * carry a qualification.
  274.          */
  275.         ;
  276.     }
  277.     else if (!in_qualifiers(N_KIND(exp_node))) {
  278.         /* a constraint check on the right hand side may be needed.*/
  279.         N_TYPE(exp_node) = base_type(t1);
  280.         apply_constraint(exp_node, t1);
  281.     }
  282.     eval_static(var_node);
  283.     eval_static(exp_node);
  284.  
  285.     noop_error = FALSE;        /* clear error flag */
  286. }
  287.  
  288. static void replace_others(Node agg_node, Node var_node, int max_dim, int dim)
  289.                                                             /*;replace_others*/
  290. {
  291.     /* This function's sole purpose is to replace the OTHERS choice in an
  292.      *  array aggregate with a RANGE choice, when the OTHERS is the only
  293.      *  choice and the aggregate is on the right side of an assignment
  294.      *  statement.  It presumes that the aggregate is properly formed
  295.      *  since that is checked elsewhere. It must call itself recursively
  296.      *  to check the higher numbered dimensions.
  297.      */
  298.  
  299.     Node association, choice_list, choices, choice;
  300.     Tuple assoc_list;
  301.     Fortup ft1;
  302.  
  303.     /* Check conditions allowing immediate return */
  304.     if (N_KIND(agg_node) != as_aggregate)
  305.         return;
  306.     if (dim > max_dim)  /* All dimensions have been checked */
  307.         return;
  308.     if ((assoc_list = N_LIST(agg_node)) == (Tuple)0 || tup_size(assoc_list) ==0)
  309.         /* Return if no entries (component associations) in aggregate */
  310.         return;
  311.  
  312.     /* Recursive call for each association's expression */
  313.     FORTUP(association = (Node), assoc_list, ft1)
  314.         replace_others(N_AST2(association), var_node, max_dim, dim + 1);
  315.     ENDFORTUP(ft1)
  316.  
  317.     /* Check for OTHERS to be replaced */
  318.     if (tup_size(assoc_list) != 1) return;
  319.     choice_list = (Node)assoc_list[1];
  320.     if (N_KIND(choice_list) != as_choice_list) return;
  321.     choices = N_AST1(choice_list);
  322.     if (N_LIST(choices) == (Tuple)0) return;
  323.     if (tup_size(N_LIST(choices)) != 1) return;
  324.     choice = (Node)N_LIST(choices)[1];
  325.     if (N_KIND(choice) != as_others_choice) return;
  326.  
  327.     /* Replace */
  328.     N_KIND(choice) = as_range_choice;
  329.     choice = (N_AST1(choice) = node_new(as_attribute));
  330.     N_AST1(choice) = node_new(as_number);
  331.     N_VAL(N_AST1(choice)) = (char *)ATTR_RANGE;
  332.     N_AST2(choice) = copy_node(var_node);
  333.     N_AST3(choice) = OPT_NODE;
  334. }
  335.  
  336. int is_variable(Node node)  /*;is_variable*/  
  337. {
  338.     /* Verify that an expression is a variable name. This is called for
  339.      * assignment statements, when validating  -out- and -inout-
  340.      * parameters in a procedure or entry call, and for generic inout parms.
  341.      */
  342.  
  343.     Node array_node, sel_node;
  344.     Node rec_node, exp_node;
  345.     int    nat ;
  346.  
  347.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  is_variable");
  348.  
  349.     switch (N_KIND(node)) {
  350.     case as_simple_name:
  351.         nat = NATURE(N_UNQ(node));
  352.         return ( nat == na_obj || nat == na_inout || nat == na_out);
  353.     case as_index:
  354.     case as_slice:
  355.         array_node  = N_AST1(node);
  356.         return (is_variable(array_node) );
  357.     case as_selector:
  358.         rec_node = N_AST1(node);
  359.         sel_node= N_AST2(node);
  360.         return (is_variable(rec_node) && NATURE(N_UNQ(sel_node)) == na_obj );
  361.     case as_all:
  362.         /* access_node = N_AST1(node);
  363.          * return (N_KIND(access_node) == as_simple_name ||
  364.          *   is_variable(access_node) ||
  365.          *   N_KIND(access_node) == as_call
  366.          *   && is_access(N_TYPE(access_node))
  367.          *     );
  368.          */
  369.         return TRUE; /* designated object is always assignable */
  370.     default:
  371.         return FALSE;
  372.     }
  373. }
  374.  
  375. void statement_list(Node node)  /*;statement_list*/
  376. {
  377.     Node    stmt_list, label_list, l;
  378.     Symbol    ls;
  379.     int    i;
  380.     Fortup    ft1;
  381.     Tuple    labs;
  382.     stmt_list = N_AST1(node);
  383.     label_list = N_AST2(node);
  384.  
  385.     /* labs := [N_UNQ(l) : l in N_LIST(label_list)]; */
  386.     labs = tup_new(tup_size(N_LIST(label_list)));
  387.     FORTUPI(l = (Node), N_LIST(label_list), i, ft1);
  388.         labs[i] = (char *) N_UNQ(l);
  389.     ENDFORTUP(ft1);
  390.     /* Within the statement list, all labels defined therein are reachable
  391.      * by goto statements in that list.
  392.      */
  393.     FORTUP(ls = (Symbol), labs, ft1);
  394.         label_status(ls) = (Tuple) label_reachable;
  395.     ENDFORTUP(ft1);
  396.     FORTUP(l = (Node), N_LIST(stmt_list), ft1);
  397.         if (N_KIND(l) != as_line_no)
  398.             adasem(l);
  399.     ENDFORTUP(ft1);
  400.  
  401.     /* On exit, these labels become unreachable.*/
  402.     FORTUP(ls = (Symbol), labs, ft1);
  403.         label_status(ls) = (int) label_unreachable;
  404.     ENDFORTUP(ft1);
  405.     tup_free(labs);
  406. }
  407.  
  408. void if_statement(Node node)                               /*;if_statement*/
  409. {
  410.     Fortup    ft1;
  411.     Node    cond_node, stmt_node, if_list, else_node, tnode;
  412.  
  413.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  if_statement");
  414.  
  415.     if_list = N_AST1(node);
  416.     else_node = N_AST2(node);
  417.  
  418.     FORTUP(tnode = (Node), N_LIST(if_list), ft1);
  419.         cond_node = N_AST1(tnode);
  420.         stmt_node = N_AST2(tnode);
  421.         adasem(cond_node);
  422.         adasem(stmt_node);
  423.     ENDFORTUP(ft1);
  424.  
  425.     adasem(else_node);
  426. }
  427.  
  428. void case_statement(Node node)                              /*;case_statement*/
  429. {
  430.     Symbol    exptype;
  431.     Node    exp_node, cases;
  432.  
  433.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  case_statement");
  434.  
  435.     exp_node = N_AST1(node);
  436.     cases = N_AST2(node);
  437.  
  438.     adasem(exp_node);
  439.     check_type_d(exp_node);
  440.     exptype = N_TYPE(exp_node);
  441.  
  442.     if (exptype == symbol_any)         /* Type error. */
  443.         return;
  444.     else
  445.         if (exptype == symbol_universal_integer)
  446.             /*exptype = symbol_integer;*/
  447.             specialize(exp_node, symbol_integer);
  448.  
  449.     process_case(exptype, cases);
  450. }
  451.  
  452. void process_case(Symbol exptype, Node cases)  /*;process_case*/
  453. {
  454.  
  455.     Forset    fs1;
  456.     int invalid_case_type;
  457.     Symbol    exp_base_type;
  458.     Node        exp_lo, exp_hi;
  459.     int    t;
  460.     int        exp_lov, exp_hiv, range_size;
  461.     Tuple    case_list, cs, tup, sig, choice_alt;
  462.     int        is_others_part;
  463.     Set        valset;
  464.     int        numval;
  465.     Node    stmt_list, choice_list, c, ch, choices;
  466.     Node    choice, lo, hi, last_choices, alternative;
  467.     Node    constraint, tmpnode;
  468.     Symbol    choicev;
  469.     int        lov, hiv, is_static;
  470.     Tuple numcon;
  471.     Node    stmts;
  472.     int        range_choice, duplicate_choice, a, b;
  473.     Fortup    ft1, ft2;
  474.     Const    con;
  475.  
  476.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  process_case");
  477.  
  478.     /* This procedure is given the type of the case expression and
  479.      * uses this type to resolve the choices appearing in the case_list.
  480.      * It also checks that the choices are static expressions and
  481.      * constructs the case statement intermediate code.
  482.      * It is called both for case statements and for variant parts.
  483.      *
  484.      * The case_list has the form
  485.      *
  486.      *    case_list ::= [ [choice_list, statement_list] ... ]
  487.      *
  488.      * where a choice_list is a sequence of choices,
  489.      *
  490.      *    choice_list ::= [choice ...]
  491.      *
  492.      * each of the form
  493.      *
  494.      *    choice ::= ["simple_choice", simp_expr ]
  495.      *          |["range_coice",   discr_range]
  496.      *          |["others_choice", OPT_NODE]
  497.      *
  498.      *
  499.      *    case_statement ::= ["case", expr, altlist, others]
  500.      *
  501.      * where
  502.      *    altlist     ::=  { {choice} -> statement_list}
  503.      * and
  504.      *    choice ::=  choiceval | ["range", choiceval, choiceval]
  505.      *
  506.      * On exit, the VAL field of each choice list is the set of discrete
  507.      * values corresponding to the choices in the list.
  508.      */
  509.     if (cdebug2 > 0) {
  510. #ifdef ERRMSG
  511.         TO_ERRFILE("case evaluation", exptype);
  512. #endif
  513.         TO_ERRFILE("case evaluation");
  514.     }
  515.  
  516.     /* Check that the case expression is of a discrete type
  517.      * and that its range is static, and find the length of
  518.      * the range.
  519.      *
  520.      */
  521.     invalid_case_type = FALSE;
  522.  
  523.     exp_base_type = base_type(exptype);
  524.  
  525.     if ( !is_discrete_type(exp_base_type)) {
  526.         errmsg("Case expression not of discrete type", "3.7.3, 5.4", cases);
  527.         invalid_case_type = TRUE;    /* Still check the alternatives*/
  528.  
  529.     }
  530.     else if (is_generic_type(exp_base_type)) {
  531.         errmsg("Case expression cannot be of a generic type", "5.4", cases);
  532.         invalid_case_type = TRUE;
  533.     }
  534.  
  535.     numcon = (Tuple) SIGNATURE(exptype);
  536.     if (numcon == (Tuple) 0 ) {
  537.         exp_lo = (Node)0;
  538.         exp_hi = (Node)0;
  539.     }
  540.     else {
  541.         exp_lo = (Node) numeric_constraint_low(numcon);
  542.         exp_hi = (Node) numeric_constraint_high(numcon);
  543.     }
  544.  
  545.     is_static = is_static_subtype(exptype);
  546.  
  547.     if (! is_static) {
  548.         tup = SIGNATURE(exp_base_type);
  549.         if (tup == (Tuple)0 ) {
  550.             exp_lo = (Node)0;
  551.             exp_hi = (Node)0;
  552.         }
  553.         else {
  554.             exp_lo = (Node) tup[2];
  555.             exp_hi = (Node) tup[3];
  556.         }
  557.         if (! is_static_expr(exp_lo) || !is_static_expr(exp_hi))
  558.             /* This alternative can arise only if the type of the
  559.              * case expression does not have static bounds.  This
  560.              * has alreay been caught, so we give no error message here,
  561.              * but only the choices are type checked and no code put out.
  562.              */
  563.             invalid_case_type = TRUE;
  564.     }
  565.  
  566.     if (! invalid_case_type) {
  567.         con = (Const) N_VAL(exp_lo);
  568.         exp_lov = (int) con->const_value.const_int;
  569.         con = (Const) N_VAL(exp_hi);
  570.         exp_hiv = con->const_value.const_int;
  571.         t = (exp_hiv - exp_lov + 1);
  572.         range_size = t > 0 ? t : 0;
  573.     }
  574.  
  575.     /* Now check each of the case choices against exp_base_type, and ensure
  576.      * that each is static.
  577.      */
  578.     case_list = N_LIST(cases);
  579.  
  580.     FORTUP(c =(Node), case_list, ft1);
  581.         /* Process statements or declarations, and resolve names in*/
  582.         /* choice expressions. */
  583.         choices = N_AST1(c);
  584.         stmts = N_AST2(c);
  585.         sem_list(choices);
  586.         adasem(stmts);
  587.     ENDFORTUP(ft1);
  588.  
  589.     is_others_part = FALSE;
  590.     valset = set_new(0);
  591.     numval = 0;
  592.     if (tup_size(case_list)) { /* empty case list is allowed */
  593.         tmpnode = (Node) case_list[tup_size(case_list)];
  594.         last_choices = N_AST1(tmpnode);
  595.         cs = N_LIST(last_choices);
  596.         if (tup_size(cs) == 1 && N_KIND((Node)cs[1]) == as_others_choice) {
  597.             is_others_part = TRUE;
  598.             /* label the whole alternative as an OTHERS choice .*/
  599.             N_KIND(tmpnode) = as_others_choice;
  600.         }
  601.  
  602.         FORTUP(alternative =(Node) , case_list, ft1);
  603.             choice_list = N_AST1(alternative);
  604.             stmt_list   = N_AST2(alternative);
  605.             choice_alt  = tup_new(0);
  606.  
  607.             FORTUP(ch=(Node), N_LIST(choice_list), ft2);
  608.                 if (N_KIND(ch) == as_others_choice) {
  609.                     is_others_part = TRUE;
  610.                     continue;
  611.                 }
  612.                 choice = N_AST1(ch);
  613.                 /* Type check the choice and  ensure that it is static,
  614.                  * in the range    for the expression  subtype, and  that
  615.                  * it appears no more than once in the list of values.
  616.                  */
  617.  
  618.                 if (N_KIND(ch) == as_choice_unresolved ) {
  619.                     find_old(choice);
  620.                     choicev = N_UNQ(choice);
  621.                     if (is_type (choicev) ) {
  622.                         if (! compatible_types(choicev, exp_base_type)) {
  623.                             errmsg_id("Choice must have type %", exp_base_type,
  624.                               "5.4", ch);
  625.                             continue;
  626.                         }
  627.                         sig = SIGNATURE(choicev);
  628.                         lo = (Node) sig[2];
  629.                         hi = (Node) sig[3];
  630.                         if (is_static_expr(lo) && is_static_expr(hi) ) {
  631.                             eval_static(lo);
  632.                             con = (Const) N_VAL(lo);
  633.                             lov = con->const_value.const_int;
  634.                             eval_static(hi);
  635.                             con = (Const) N_VAL(hi);
  636.                             hiv = con->const_value.const_int;
  637.                         }
  638.                         else {
  639.                             errmsg("Case choice not static", "3.7.3, 5.4", ch);
  640.                             continue;
  641.                         }
  642.                         /* Reformat node as a simple type name. */
  643.                         copy_attributes(choice, ch);
  644.                     }
  645.                     else        /* expression: resolve below.*/
  646.                         N_KIND(ch) = as_simple_choice;
  647.                 }
  648.                 if (N_KIND(ch) == as_simple_choice) {
  649.                     check_type(exp_base_type, choice);
  650.  
  651.                     if (N_TYPE(choice) == symbol_any || invalid_case_type )
  652.                         continue;
  653.                     else if (is_static_expr(choice)) {
  654.                         con = get_static_nval(choice);
  655.                         if (con == (Const)0)   /* previous error (?) */
  656.                             continue;
  657.                         lov = con->const_value.const_int;
  658.                         lo = hi = choice;
  659.                         hiv = lov;
  660.                     }
  661.                     else {
  662.                         errmsg("Case choice not static", "3.7.3, 5.4", ch);
  663.                         continue;
  664.                     }
  665.                 }
  666.                 else if (N_KIND(ch) == as_range_choice) {
  667.                     check_type(exp_base_type, choice);
  668.                     if (N_TYPE(choice) == symbol_any || invalid_case_type)
  669.                         continue;
  670.                     else {
  671.                         constraint = N_AST2(choice);
  672.                         lo = N_AST1(constraint);
  673.                         hi = N_AST2(constraint);
  674.                         if (is_static_subtype(N_TYPE(choice))
  675.                           && is_static_expr(lo) && is_static_expr(hi)) {
  676.                             con = get_static_nval(lo);
  677.                             lov = con->const_value.const_int;
  678.                             con = get_static_nval(hi);
  679.                             hiv = con->const_value.const_int;
  680.                         }
  681.                         else {
  682.                             errmsg("Case choice not static", "3.7.3, 5.4", ch);
  683.                             continue;
  684.                         }
  685.                     }
  686.                 }
  687.             /* At this point the choice is known to be static and is expressed
  688.              * as a range [lov, hiv].
  689.              */
  690.                 if (is_static && (lov<=hiv) && (lov<exp_lov || hiv > exp_hiv)) {
  691.                     errmsg_l("choice value(s) not in range of static ",
  692.                       "subtype of case expression", "5.4", ch);
  693.                 }
  694.                 /* Remove junk values from below*/
  695.                 if (lov < exp_lov) lov = exp_lov;
  696.                 /* Remove junk values from above*/
  697.                 if (hiv > exp_hiv) hiv = exp_hiv;
  698.  
  699.                 /* normalize all nodes to be ranges. */
  700.                 N_KIND(ch) = as_range;
  701.                 N_AST1(ch) = lo;
  702.                 N_AST2(ch) = hi;
  703.  
  704.                 if (lov > hiv )            /* Null range -- ignore it.*/
  705.                     continue;
  706.  
  707.                 /* Ensure that range is disjoint from all others. */
  708.  
  709.                 range_choice = hiv > lov;
  710.                 duplicate_choice = FALSE;
  711.  
  712.                 FORSET(tup =(Tuple) , valset, fs1);
  713.                     if (lov >= (int) tup[1] && lov <= (int)tup[2]) {
  714.                         duplicate_choice = TRUE;
  715.                         lov = (int)tup[2] + 1;
  716.                         break;
  717.                     }
  718.                 ENDFORSET(fs1);
  719.  
  720.                 if (range_choice) {
  721.                     FORSET(tup = (Tuple), valset, fs1);
  722.                         a = (int) tup[1]; 
  723.                         b = (int) tup[2];
  724.                         if (hiv >= a && hiv <= b) {
  725.                             duplicate_choice = TRUE;
  726.                             hiv = a - 1;
  727.                             break;
  728.                         }
  729.                     ENDFORSET(fs1);
  730.                 }
  731.                 if (range_choice) {
  732.                     FORSET(tup = (Tuple), valset, fs1);
  733.                         a = (int) tup[1]; 
  734.                         b = (int) tup[2];
  735.                         if (lov<a && hiv>b) {
  736.                             duplicate_choice = TRUE;
  737.                             break;
  738.                         }
  739.                     ENDFORSET(fs1);
  740.                 }
  741.                 if (duplicate_choice) {
  742.                     errmsg("Duplicate choice value(s)", "3.7.3, 5.4", ch);
  743.                 }
  744.  
  745.                 if (lov > hiv)                /*Again check for null range*/
  746.                     continue;
  747.  
  748.                 /* Add interval to set of values seen so far, add the number 
  749.                   * of choices to the count of values covered. 
  750.                   */
  751.                 tup = tup_new(2);
  752.                 tup[1] = (char *) lov;
  753.                 tup[2] = (char *) hiv;
  754.                 valset = set_with(valset, (char *)tup);
  755.                 numval += (hiv - lov + 1);
  756.  
  757.                 /* finally, normalize all nodes to be discrete ranges. */
  758.                 N_KIND(ch) = as_range;
  759.                 N_AST1(ch) = lo;
  760.                 N_AST2(ch) = hi;
  761.             ENDFORTUP(ft2);
  762.         ENDFORTUP(ft1);
  763.     }
  764.     /* Check that all of the possibilities in the range of the
  765.      * case expression have been used.
  766.      */
  767.     if  (! invalid_case_type && ! is_others_part
  768.       && (numval != range_size || exptype == symbol_universal_integer))
  769.     {
  770.         errmsg("Missing OTHERS choice", "3.7.3, 5.4", cases);
  771.     }
  772. }
  773.  
  774. int is_static_subtype(Symbol subtype)  /*;is_static_subtype*/
  775. {
  776.     Symbol    bt;
  777.     Node lo, hi;
  778.     Tuple tup;
  779.  
  780.     bt = TYPE_OF(subtype);
  781.     if (is_generic_type(bt) || in_incp_types(bt) || (! is_scalar_type(bt)))
  782.         /*  RM 4.9 (11) */
  783.         return FALSE;
  784.     else if (bt == subtype)
  785.         return TRUE;
  786.     else {
  787.         tup = (Tuple) SIGNATURE(subtype);
  788.         lo = (Node) tup[2];
  789.         tup = (Tuple) SIGNATURE(subtype);
  790.         hi = (Node) tup[3];
  791.         return (is_static_subtype(bt)
  792.           && N_KIND(lo) == as_ivalue && N_KIND(hi) == as_ivalue);
  793.     }
  794. }
  795.  
  796. static Const get_static_nval(Node node)            /*;get_static_nval */
  797. {
  798.     /* a choice may be a qualification, or it may carry a (spurious) constraint
  799.      * check. Reformat node to be a ivalue, as we know it is in bounds.
  800.      */
  801.  
  802.     int kind;
  803.  
  804.     kind = N_KIND(node);
  805.     if (kind == as_qual_range) {
  806.         copy_attributes(N_AST1(node), node);
  807.         return get_static_nval(node);
  808.     }
  809.     else if (kind == as_qualify || kind == as_convert) {
  810.         copy_attributes(N_AST2(node), node);
  811.         return get_static_nval(node);
  812.     }
  813.     else return (Const)N_VAL(node);
  814. }
  815.  
  816. void new_block(Node node)                                /*;new_block*/
  817. {
  818.     Node    id_node, decl_node, stmt_node, handler_node;
  819.     Symbol    block_name;
  820.  
  821.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  new_block");
  822.  
  823.     id_node = N_AST1(node);
  824.     decl_node  = N_AST2(node);
  825.     stmt_node = N_AST3(node);
  826.     handler_node = N_AST4(node);
  827.  
  828.     /* block names are declared when procedure containing them is entered. */
  829.     block_name = N_UNQ(id_node);
  830.  
  831.     NATURE(block_name) = na_block;
  832.     newscope(block_name);
  833.     adasem(decl_node);
  834.     adasem(stmt_node);
  835.     adasem(handler_node);
  836.     check_incomplete_decls(block_name, decl_node);
  837.     popscope();
  838.     force_all_types();
  839. }
  840.  
  841. void loop_statement(Node node)                          /*;loop_statement*/
  842. {
  843.     Tuple    t;
  844.     Symbol    loop_name;
  845.     Node    id_node, iter_node, stmt_node;
  846.  
  847.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  loop_statement");
  848.  
  849.     id_node = N_AST1(node);
  850.     iter_node  = N_AST2(node);
  851.     stmt_node = N_AST3(node);
  852.  
  853.     /* loop names are declared when procedure containing them is entered.*/
  854.  
  855.     find_old(id_node);
  856.     loop_name = N_UNQ(id_node);
  857.     NATURE(loop_name) = na_block;
  858.     OVERLOADS(loop_name) = (Set) BLOCK_LOOP;
  859.     t = tup_new(1);
  860.     t[1] = (char *) FALSE;
  861.     SIGNATURE(loop_name) = t;
  862.     /* The loop is the scope of definition of the iteration variable.  */
  863.     newscope(loop_name);
  864.     adasem(iter_node);
  865.     adasem(stmt_node);
  866.  
  867.     popscope();    /* Exit from loop scope.*/
  868. }
  869.  
  870. /*?? is return needed */
  871. Symbol iter_var(Node node)  /*;iter_var*/
  872. {
  873.     Node    id_node, range_node, def_node;
  874.     Symbol    loop_var, iter_type, type_def;
  875.     Tuple    t, tt, toptup, it;
  876.     int    n; 
  877.     char *id;
  878.  
  879.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  iter_var");
  880.  
  881.     id_node = N_AST1(node);
  882.     range_node = N_AST2(node);
  883.     adasem(range_node);
  884.     id = N_VAL(id_node);
  885.  
  886.     /* Insert loop variable in scope of loop. */
  887.     loop_var = find_new(id);
  888.     N_UNQ(id_node) = loop_var;
  889.  
  890.     /* If the iteration is given by a discrete range, construct an anonymous
  891.      * type for it, and save the defining expression. It is     emitted as part
  892.      * of the loop header.
  893.      */
  894.     iter_type = make_index(range_node);  /* $$$ PERHAPS */
  895.     n = tup_size(newtypes);
  896.     toptup = (Tuple) newtypes[n]; /* top newtypes */
  897.     if ((Symbol)toptup[tup_size(toptup)] == iter_type) {
  898.         /* Remove from anonymous types, and save subtype definition. */
  899.         it = (Tuple)tup_frome(toptup);
  900.         type_def = (Symbol) subtype_expr(iter_type);
  901.     }
  902.     else
  903.         type_def = (Symbol) tup_new(0);
  904.     NATURE(loop_var) = na_constant;
  905.     TYPE_OF(loop_var) = iter_type;
  906.     /* create dummy non-static default expression node for this (dummy) const */
  907.     def_node = node_new(as_simple_name);
  908.     N_VAL(def_node) = "";
  909. #ifdef IBM_PC
  910.     N_VAL(def_node) = strjoin("",""); /* copy literal */
  911. #endif
  912.     N_UNQ(def_node) = symbol_undef;
  913.     default_expr(loop_var) = (Tuple) def_node;
  914.  
  915.     t = tup_new(2);
  916.     t[1] = (char *) iter_type;
  917.     t[2] = (char *) type_def;
  918.     tt = SIGNATURE(scope_name);
  919.     tt = tup_with(tt, (char *) t);
  920.     SIGNATURE(scope_name) = tt;
  921.     return loop_var;
  922. }
  923.  
  924. void exit_statement(Node node)  /*;exit_statement*/
  925. {
  926.     Node    id_node, cond_node;
  927.     Symbol    scope, sc;
  928.     int    exists;
  929.     Fortup    ft1;
  930.     char    *id;
  931.     Tuple    tup;
  932.  
  933.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  exit_statement");
  934.  
  935.     id_node = N_AST1(node);
  936.     cond_node = N_AST2(node);
  937.  
  938.     /* An unqualified exit refers to the innermost enclosing scope.  */
  939.     if (id_node == OPT_NODE) {
  940.         exists = FALSE;
  941.  
  942.         FORTUP(scope = (Symbol), open_scopes, ft1);
  943.             if ((int)OVERLOADS(scope) == BLOCK_LOOP) {
  944.                 /* Indicate that loop label must be emitted. */
  945.                 tup = SIGNATURE(scope); 
  946.                 tup[1] = (char *)TRUE;
  947.                 exists = TRUE;
  948.                 break;
  949.             }
  950.         ENDFORTUP(ft1);
  951.         if (! exists) {
  952.             errmsg("EXIT statement not in loop", "5.7", node);
  953.             return;
  954.         }
  955.     }
  956.     else {
  957.         id = N_VAL(id_node);
  958.         /* Verify that loop label exists.*/
  959.         exists = FALSE;
  960.         FORTUP(scope = (Symbol), open_scopes, ft1);
  961.             if (((int)OVERLOADS(scope) == BLOCK_LOOP)
  962.               && streq(original_name(scope), id)) {
  963.                 tup = SIGNATURE(scope);
  964.                 tup[1] = (char *) TRUE;
  965.                 exists = TRUE;
  966.                 break;
  967.             }
  968.         ENDFORTUP(ft1);
  969.         if (! exists) {
  970.             errmsg_str("Invalid loop label in EXIT: %",id, "5.5, 5.7", id_node);
  971.             return;
  972.         }
  973.     }
  974.     N_UNQ(node) = scope;
  975.  
  976.     /* Now verify that the exit statement does not try to exit from
  977.      * a procedure, task, package or accept statement. This amounts
  978.      * to requiring that the scope stack contain only blocks up to the
  979.      * scope being exited.
  980.      */
  981.     FORTUP(sc = (Symbol), open_scopes, ft1);
  982.         if (sc == scope) break;
  983.         else if (NATURE(sc) != na_block) {
  984.             errmsg_nat("attempt to exit from %", sc, "5.7", node);
  985.             break;
  986.         }
  987.     ENDFORTUP(ft1);
  988.  
  989.     adasem(cond_node);
  990. }
  991.  
  992. void return_statement(Node node)                    /*;return_statement*/
  993. {
  994.     Node    exp_node, proc_node;
  995.     int    j, nat, out_depth, certain;
  996.     Symbol    r_type, proc_name, tsym;
  997.     Fortup ft1;
  998.     int    i, blktyp;
  999.  
  1000.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  return_statement");
  1001.  
  1002.     exp_node = N_AST1(node);
  1003.  
  1004.     /* Find subprogram or accept statement which is enclosing scope, and keep
  1005.      * track of the     number     of blocks that     have  to  be exited. This number
  1006.      * is kept in the N_AST3 field for the node.
  1007.      * The N_AST of the node receives an additional
  1008.      * simple node to hold the unique name of the subprogram being exited. 
  1009.      */
  1010.     has_return_stk[tup_size(has_return_stk)] = (char *)TRUE;
  1011.  
  1012.     certain = FALSE;
  1013.     FORTUPI(proc_name = (Symbol), open_scopes, i, ft1);
  1014.         nat = NATURE(proc_name);
  1015.         if (nat != na_block) {
  1016.             certain = TRUE;
  1017.             break;
  1018.         }
  1019.     ENDFORTUP(ft1);
  1020.     out_depth = i - 1;
  1021.  
  1022.     /* Exception handlers are blocks for syntactic purposes, but not at
  1023.      * run-time. They must be excluded from this count.
  1024.      * The same is true for loops.
  1025.      */
  1026.     for (j = 1; j <= i; j++) {
  1027.         tsym = (Symbol) open_scopes[j];
  1028.         blktyp = (int)OVERLOADS(tsym);
  1029.         if (blktyp == BLOCK_HANDLER || blktyp == BLOCK_LOOP) out_depth -= 1;
  1030.     }
  1031.     if ((nat == na_function || nat == na_procedure 
  1032.       || nat == na_generic_function || nat == na_generic_procedure
  1033.       || nat == na_entry || nat == na_entry_family)) {
  1034.         ;
  1035.     }
  1036.     else {
  1037.         errmsg("invalid context for RETURN statement", "5.8", node);
  1038.         return;
  1039.     }
  1040.     r_type = nat == na_entry_family ? symbol_none : TYPE_OF(proc_name);
  1041.     if (exp_node != OPT_NODE) {
  1042.         if (r_type == symbol_none) {
  1043.             errmsg("Procedure cannot return value", "5.8", exp_node);
  1044.         }
  1045.         else {
  1046.             /* If the value returned is an aggregate, there is no sliding
  1047.              * for it, and named associations can appear together with 
  1048.              * "others" (see 4.3.2(6)).
  1049.              */
  1050.             full_others = TRUE;
  1051.             adasem(exp_node);
  1052.             check_type(r_type, exp_node);
  1053.             full_others = FALSE;
  1054.         }
  1055.     }
  1056.     else if (r_type != symbol_none) {
  1057.         errmsg("Function must return value", "5.8", node);
  1058.     }
  1059.  
  1060.     proc_node = node_new(as_simple_name);
  1061.     N_UNQ(proc_node) = proc_name;
  1062.     N_AST1(node) =    exp_node;
  1063.     N_AST2(node) = proc_node;
  1064.     N_AST3(node) = new_number_node(out_depth);
  1065.     N_AST4(node) = (Node) 0;
  1066. }
  1067.  
  1068. void label_decl(Node node)                          /*;label_decl*/
  1069. {
  1070.     Symbol label;
  1071.     Fortup    ft1;
  1072.     char    *id;
  1073.     Tuple tlabs;
  1074.     Node    id_node;
  1075.  
  1076.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  label_decl");
  1077.  
  1078.     FORTUP(id_node = (Node), N_LIST(node), ft1);
  1079.         id = N_VAL(id_node);
  1080.         label = find_new(id);
  1081.         N_UNQ(id_node) = label;
  1082.         if (NATURE(label) == na_void
  1083.           && !tup_mem((char *) label , (Tuple) lab_seen[tup_size(lab_seen)])) {
  1084.             NATURE(label) = na_label;
  1085.             label_status(label) = (int) label_unreachable;
  1086.  
  1087.             /* top(lab_seen) with:= label; */
  1088.             tlabs = (Tuple) lab_seen[tup_size(lab_seen)];
  1089.             tlabs = tup_with(tlabs, (char *) label);
  1090.             lab_seen[tup_size(lab_seen)] = (char *) tlabs;
  1091.         }
  1092.         else {
  1093.             errmsg("Duplicate identifier for label", "5.1", id_node);
  1094.         }
  1095.     ENDFORTUP(ft1);
  1096. }
  1097.  
  1098. void lab_init()                                            /*;lab_init*/
  1099. {
  1100.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  lab_init ");
  1101.  
  1102.     lab_seen = tup_with(lab_seen, (char *) tup_new(0));
  1103. }
  1104.  
  1105. void lab_end()                                          /*;lab_end*/
  1106. {
  1107.     char    *old_labels;
  1108.  
  1109.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  lab_end ");
  1110.     /* The value of old_labels is irrelevant, as we are just removing
  1111.      * last element from lab_seen
  1112.      */
  1113.     old_labels = tup_frome(lab_seen);
  1114. }
  1115.  
  1116. void goto_statement(Node node)                           /*;goto_statement*/
  1117. {
  1118.     Node    id_node, id;
  1119.     Symbol    label, s;
  1120.     Fortup    ft1;
  1121.  
  1122.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  goto_statement");
  1123.  
  1124.     id_node = N_AST1(node);
  1125.     id = (Node) N_VAL(id_node); /*?? id is never used */
  1126.  
  1127.     find_old(id_node);
  1128.     label = N_UNQ(id_node);
  1129.  
  1130.     if (NATURE(label) != na_label) {
  1131.         errmsg("target of goto is not a label", "5.9", id_node);
  1132.  
  1133.     }
  1134.     else if ((int)label_status(label) == label_unreachable) {
  1135.         errmsg("target of goto is not a reachable label", "5.9", id_node);
  1136.     }
  1137.     else {
  1138.         FORTUP(s = (Symbol), open_scopes, ft1);
  1139.             if (s == SCOPE_OF(label)) break;
  1140.             else if (NATURE(s) != na_block) {
  1141.                 errmsg_nat("attempt to jump out of %", s, "5.9", node);
  1142.             }
  1143.  
  1144.         ENDFORTUP(ft1);
  1145.     }
  1146. }
  1147.